home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources1 / Runtime (.c & .h) / mem.c < prev    next >
Encoding:
Text File  |  1992-06-04  |  17.5 KB  |  461 lines  |  [TEXT/KAHL]
  1. /* Memory allocation */
  2.  
  3. #include "params.h"
  4. #include "gambit.h"
  5. #include "struct.h"
  6. #include "os.h"
  7. #include "mem.h"
  8. #include "strings.h"
  9. #include "opcodes.h"
  10. #include "stats.h"
  11. #include "main.h"
  12.  
  13.  
  14. /*---------------------------------------------------------------------------*/
  15.  
  16.  
  17. void (*temp_cont)();
  18. char *heap_area1, *heap_area2;
  19. long random_seed;
  20. long processor_id;
  21. PSTATE_PTR processor_state[MAX_NB_PROC];
  22.  
  23.  
  24.  
  25. void init_system_mem1();
  26.  
  27.  
  28. void init_system_mem( cont )
  29. void (*cont)();
  30. {
  31.  
  32. /*
  33.  
  34. This procedure allo, obj )
  35. long len, subtype;
  36. SCM_obj *obj;
  37. { long len1 = len + 4;        /* length including header                */
  38.   long len2 = ceiling8(len1); /* length including padding for alignment */
  39.   if (sstate->const_bptr+len2 > sstate->const_tptr)
  40.   { os_err = "Constant area overflow"; return 1; }
  41.   *obj = (SCM_obj)(sstate->const_bptr + SCM_type_SUBTYPED);
  42.   *(long *)(sstate->const_bptr) = SCM_make_header( len, subtype );
  43.   sstate->const_bptr += len2;
  44.   return 0;
  45. }
  46.  
  47.  
  48. long alloc_const_vector( len, obj )
  49. long len;
  50. SCM_obj *obj;
  51. { return alloc_const_subtyped( len*sizeof(SCM_obj), (long)SCM_subtype_VECTOR, obj );
  52. }
  53.  
  54.  
  55. long alloc_const_string( str, obj )
  56. char *str;
  57. SCM_obj *obj;
  58. { SCM_obj string_adr;
  59.   char *p = str;
  60.   long len = 0;
  61.   while (*(p++) != '\0') len++;
  62.   if (alloc_const_subtyped( len+1, (long)SCM_subtype_STRING, &string_adr )) return 1;
  63.   p = (char *)(string_adr - SCM_type_SUBTYPED + 4);
  64.   while (*str != '\0') *(p++) = *(str++);
  65.   *p = '\0'; /* so that C will understand this as a string */
  66.   if ((((long)p) & 7) == 0) { *(long *)p = 0; *(long *)(p+4) = 0; }
  67.   *obj = string_adr;
  68.   *(long *)(string_adr-SCM_type_SUBTYPED) = SCM_make_header( len, SCM_subtype_STRING );
  69.   return 0;
  70. }
  71.  
  72.  
  73. void define_c_proc( name, proc )
  74. char *name;
  75. void (*proc)();
  76. { SCM_obj proc_adr;
  77.   short *code_ptr;
  78.   char *str = c_id_to_symbol( name );
  79.   if (str == NULL)
  80.   { os_warn( "Can't convert C identifier to Scheme symbol\n", 0L ); os_quit(); }
  81.   if (alloc_const_proc( 16L, &proc_adr ))
  82.   { os_warn( "%s\n", (long)os_err ); os_quit(); }
  83.   code_ptr = (short *)proc_adr;
  84.  
  85.   *(code_ptr++) = MOVE_L_IMM_A1_OP;      /* move.l #adr,a1    */
  86.   *(void (**)())code_ptr = proc;  code_ptr += 2;
  87.   *(code_ptr++) = JMPA6_DISP_OP;         /* jmp    C_CALL(a6) */
  88.   *(code_ptr++) = table_offset( &sstate->traps[C_CALL_trap].jmp );
  89.   *((SCM_obj *)code_ptr) = SCM_false;  code_ptr += 2;
  90.   *((SCM_obj *)code_ptr) = SCM_int_to_obj( 2 );
  91.  
  92.   if (set_global( str, proc_adr )) { os_warn( "%s\n", (long)os_err ); os_quit(); }
  93. }
  94.  
  95.  
  96. /*---------------------------------------------------------------------------*/
  97.  
  98.  
  99. void init_processor_mem1();
  100. void init_processor_mem2();
  101. void init_processor_mem3();
  102. void init_processor_mem4();
  103.  
  104.  
  105. void init_processor_mem( cont )
  106. void (*cont)();
  107. {
  108.  
  109. /*
  110.  
  111. This procedure allocates storage associated with each processor.
  112. Specifically, there are 8 areas of storage per processor:
  113.  
  114.   1 - table used to store events
  115.   2 - local heap (for storing non-Scheme objects)
  116.   3 - counters used for statistics gathering
  117.   4 - code area for the emulation of M68020 and M68881 instructions
  118.   5 - processor state
  119.   6 - Scheme heap (where the processor allocates most Scheme objects)
  120.   7 - counters used for profiling (if requested)
  121.   8 - the stack (and lazy-task queue and dynamic-binding queue)
  122.       note: the lazy-task queue could be in private-memory for the message
  123.       passing steal protocol but, to test the alternative shared memory steal
  124.       protocol, it is put in shared memory (on the butterfly this doesn't
  125.       affect performance anyway)
  126.  
  127. The processor state is a structure that contains a number of fields that
  128. describe a given processor (i.e. processor number, heap location,
  129. stack location, etc...).
  130.  
  131. The Scheme heap is a block of memory containing two equaly sized sub-heaps
  132. each starting on an octuple address:
  133.  
  134. processor.heap_bot       _________
  135.           ------------> |    .    | \
  136.                         |    .    |  | sub-heap 1 (first to be used)
  137.                         |    .    |  |
  138.                         |_________| /
  139.                         |    .    | \
  140.                         |    .    |  | sub-heap 2
  141.                         |    .    |  |
  142. processor.heap_top      |_________| /
  143.           ------------>
  144.  
  145. */
  146.  
  147.   temp_cont = cont;
  148.  
  149.   init_stats();
  150.  
  151.   processor_id = 0;
  152.   random_seed = 0;
  153.  
  154.   init_processor_mem1();
  155. }
  156.  
  157.  
  158. void init_processor_mem1()
  159. { long prof_len = ceiling8(sstate->profiling ? ((sizeof(short) * ceiling8( const_len )) >> PROF_SHIFT) : 0);
  160.  
  161.   os_shared_malloc8( (remote_stack ? 0 : (2*stack_len)) +
  162.                      ceiling8( ((long)MAX_NB_EVENTS)*sizeof(long) ) +
  163.                      ((long)LOCAL_HEAP_LENGTH_IN_K)*K +
  164.                      ceiling8( ((long)MAX_NB_STATS)*sizeof(long) ) +
  165.                      ceiling8( ((long)MAX_EMUL_CODE_LENGTH_IN_K)*K ) +
  166.                      ceiling8( sizeof(struct pstate_rec) ) +
  167.                      prof_len +
  168.                      (remote_heap ? 0 : heap_len),
  169.                      processor_id,
  170.                      init_processor_mem2 );
  171. }
  172.  
  173.  
  174. void init_processor_mem2( ptr )
  175. char *ptr;
  176. { if (ptr == NULL)
  177.   { os_warn( "Can't allocate heap area\n", 0L ); os_quit(); }
  178.  
  179.   heap_area1 = ptr;
  180.  
  181.   if (remote_heap)
  182.     os_shared_malloc8( heap_len, 1L, init_processor_mem3 );
  183.   else
  184.     init_processor_mem3( heap_area1 );
  185. }
  186.  
  187.  
  188. void init_processor_mem3( ptr )
  189. char *ptr;
  190. { if (ptr == NULL)
  191.   { os_warn( "Can't allocate remote heap\n", 0L ); os_quit(); }
  192.  
  193.   heap_area2 = ptr;
  194.  
  195.   if (remote_stack)
  196.     os_shared_malloc8( 2*stack_len, 1L, init_processor_mem4 );
  197.   else
  198.     init_processor_mem4( heap_area1 );
  199. }
  200.  
  201.  
  202. void init_processor_mem4( ptr )
  203. char *ptr;
  204. { if (ptr == NULL)
  205.   { os_warn( "Can't allocate remote stack\n", 0L ); os_quit(); }
  206.  
  207.   { long prof_len = ceiling8(sstate->profiling ? ((sizeof(short) * ceiling8( const_len )) >> PROF_SHIFT) : 0);
  208.  
  209.     char *ptr0 = heap_area1 + (remote_stack ? 0 : (2*stack_len));
  210.     char *ptr1 = ptr0 + ceiling8( ((long)MAX_NB_EVENTS)*sizeof(long) );
  211.     char *ptr2 = ptr1 + ((long)LOCAL_HEAP_LENGTH_IN_K)*K;
  212.     char *ptr3 = ptr2 + ceiling8( ((long)MAX_NB_STATS)*sizeof(long) );
  213.     char *ptr4 = ptr3 + ceiling8( ((long)MAX_EMUL_CODE_LENGTH_IN_K)*K );
  214.     char *ptr5 = ptr4 + ceiling8( sizeof(struct pstate_rec) );
  215.     char *ptr6 = (remote_heap ? heap_area2 : (ptr5+prof_len));
  216.     PSTATE_PTR p = (PSTATE_PTR)ptr4;
  217.     long i;
  218.  
  219.     processor_state[processor_id] = p;
  220.  
  221.     p->id                = SCM_int_to_obj(processor_id);
  222.     p->nb_processors     = SCM_int_to_obj(nb_processors);
  223.     p->stats_counters    = (long *)ptr2;
  224.     p->local_heap_bot    = ptr1;
  225.     p->local_heap_top    = ptr2;
  226.  
  227.     p->stack_bot         = (long *)ptr;
  228.     p->stack_top         = (long *)(((char *)p->stack_bot) + stack_len);
  229.     p->q_bot             = (long **)p->stack_top;
  230.     p->q_top             = (long **)(((char *)p->stack_top) + stack_len);
  231.     p->stack_max_margin  = ((stack_len-STACK_ALLOCATION_FUDGE*4)/8) & -8L;
  232.     p->stack_margin      = p->stack_max_margin;
  233.  
  234.     p->heap_bot          = ptr6;
  235.     p->heap_top          = ptr6 + heap_len;
  236.     p->heap_mid          = ptr6 + heap_len/2;
  237.     p->heap_max_margin   = ((heap_len/2-HEAP_ALLOCATION_FUDGE*4)/16) & -8L;
  238.     p->heap_margin       = p->heap_max_margin;
  239.     p->elog_bot          = (long *)ptr0;
  240.     p->elog_top          = ((long *)ptr1)-2;
  241.     p->prof_bot          = (short *)ptr5;
  242.     p->prof_top          = (short *)(ptr5+prof_len);
  243.     p->emul_code_bot     = ptr3;
  244.     p->emul_code_top     = ptr4;
  245.  
  246.     p->intr_flag         = -1;
  247.     p->heap_old          = p->heap_mid;
  248.     p->heap_lim          = p->heap_bot + p->heap_margin + ((long)HEAP_ALLOCATION_FUDGE)*4;
  249.     p->heap_ptr          = p->heap_mid;
  250.     p->closure_lim       = p->heap_ptr;
  251.     p->closure_ptr       = p->heap_ptr;
  252.     p->workq_lockO       = 0;  /* work queue initially unlocked */
  253.     p->workq_lockV       = 0;
  254.     p->workq_tail        = SCM_null;
  255.     p->workq_head        = SCM_null;
  256.     p->steal_scan        = 0;
  257.     p->elog_ptr          = p->elog_top;
  258.     p->elog_top[0]       = 0;
  259.     p->elog_top[1]       = 0;
  260.     p->emul_code_ptr     = p->emul_code_bot;
  261.     p->local_heap_ptr    = p->local_heap_bot;
  262.  
  263.     p->steal_lockO       = 0;
  264.     p->steal_lockV       = 0;
  265.  
  266.     p->stack_ptr         = p->stack_top;
  267.     p->ltq_tail          = p->q_bot;
  268.     *(p->ltq_tail++)     = p->stack_ptr;
  269.     p->ltq_head          = p->ltq_tail;
  270.     p->deq_tail          = p->q_top;
  271.     *(--p->deq_tail)     = p->stack_ptr;
  272.     p->deq_head          = p->deq_tail;
  273.  
  274.     { long **z = p->ltq_tail;
  275.       while (z != p->deq_tail) *z++ = NULL;
  276.     }
  277.  
  278.     p->response          = 0;
  279.     p->thief             = 0;
  280.  
  281.     p->intr_other        = 0;
  282.     p->intr_barrier      = 0;
  283.     p->intr_timer        = 0;
  284.     p->intr_user         = 0;
  285.  
  286.     p->sync1             = -2;
  287.     p->sync2             = -2;
  288.  
  289.     p->count1            = 0;
  290.     p->count2            = 0;
  291.  
  292.     for (i=(sizeof(p->processor_storage)/sizeof(SCM_obj))-1; i>=0; i--)
  293.       p->processor_storage[i] = 0;
  294.   }
  295.  
  296.   processor_id++;
  297.  
  298.   if (processor_id<nb_processors)
  299.     init_processor_mem1();
  300.   else
  301.   { long i, j, index;
  302.  
  303.     for (i=0; i<nb_processors; i++)  /* setup table of processors on each proc */
  304.     { PSTATE_PTR *p1 = processor_state[i]->ps, *p2 = processor_state;
  305.       PSTATE_PTR *p3 = processor_state[i]->steal_ps;
  306.       for (j=0; j<nb_processors; j++) *(p1++) = *(p2++);
  307.       *(p3++) = processor_state[i];
  308.       for (j=1; j<nb_processors; j++) *(p3++) = processor_state[(i+j)%nb_processors];
  309.  
  310.       for (j=1; j<nb_processors; j++)  /* shuffle to randomize steal pattern */
  311.       { long k = random_seed % (nb_processors-j);
  312.         PSTATE_PTR temp = *(--p3);
  313.         *p3 = *(p3-k);
  314.         *(p3-k) = temp;
  315.         random_seed = (random_seed * 7001 + 1) & 0x7fffffffL;
  316.       }
  317.     }
  318.  
  319.     pstate = processor_state[0];
  320.   
  321.     if (alloc_vector( (long)SYMBOL_TABLE_LENGTH, &sstate->globals[SYMBOL_TABLE].value )) os_quit();
  322.  
  323.     for (i=0; i<SYMBOL_TABLE_LENGTH; i++)
  324.       SCM_obj_to_vect(sstate->globals[SYMBOL_TABLE].value)[i] = SCM_null;
  325.     sstate->globals[GLOBAL_VAR_COUNT].value = SCM_int_to_obj( 0 );
  326.  
  327.     if (alloc_global( "##symbol-table", &index ) ||               /* variable # 0 */
  328.         alloc_global( "##global-var-count", &index )) os_quit();  /* variable # 1 */
  329.  
  330.     temp_cont();
  331.   }
  332. }
  333.  
  334.  
  335. long alloc_pair( obj )
  336. SCM_obj *obj;
  337. { if (pstate->heap_ptr-8 < pstate->heap_lim)
  338.   { os_err = "Heap overflow"; return 1; }
  339.   pstate->heap_ptr -= 8;
  340.   *obj = (SCM_obj)(pstate->heap_ptr + SCM_type_PAIR);
  341.   return 0;
  342. }
  343.  
  344.  
  345. long alloc_subtyped( len, subtype, obj )
  346. long len, subtype;
  347. SCM_obj *obj;
  348. { long len1 = len + 4;        /* length including header                */
  349.   long len2 = ceiling8(len1); /* length including padding for alignment */
  350.   if (pstate->heap_ptr-len2 < pstate->heap_lim)
  351.   { os_err = "Heap overflow"; return 1; }
  352.   pstate->heap_ptr -= len2;
  353.   *(long *)(pstate->heap_ptr) = SCM_make_header( len, subtype );
  354.   *obj = (SCM_obj)(pstate->heap_ptr + SCM_type_SUBTYPED);
  355.   return 0;
  356. }
  357.  
  358.  
  359. long alloc_vector( len, obj )
  360. long len;
  361. SCM_obj *obj;
  362. { return alloc_subtyped( len*sizeof(SCM_obj), (long)SCM_subtype_VECTOR, obj );
  363. }
  364.  
  365.  
  366. long alloc_symbol( name, obj )
  367. char *name;
  368. SCM_obj *obj;
  369. { SCM_obj probe, sym, sym_name;
  370.   long len = 0, h = 0;
  371.   while (name[len] != '\0')
  372.     h = ((h<<8)+(unsigned)name[len++]) % (long)SYMBOL_TABLE_LENGTH;
  373.   probe = SCM_obj_to_vect(sstate->globals[SYMBOL_TABLE].value)[h];
  374.   while (probe != SCM_null)
  375.   { sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
  376.     sym_name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
  377.     if (SCM_length( sym_name ) == len)
  378.     { long i = len;
  379.       char *str = SCM_obj_to_str(sym_name);
  380.       while (i > 0) { i--; if (str[i] != name[i]) goto not_found; }
  381.       *obj = sym;
  382.       return 0;
  383.     }
  384.     not_found:
  385.     probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
  386.   }
  387.  
  388.   if (alloc_subtyped( ((long)SYMBOL_SIZE)*sizeof(SCM_obj), (long)SCM_subtype_SYMBOL, &sym )) return 1;
  389.   if (alloc_const_string( name, &SCM_obj_to_vect(sym)[SYMBOL_NAME])) return 1;
  390.   SCM_obj_to_vect(sym)[SYMBOL_PLIST]  = SCM_null;
  391.   SCM_obj_to_vect(sym)[SYMBOL_GLOBAL] = SCM_false;
  392.   if (alloc_pair( &probe )) return 1;
  393.   *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj)) = sym;
  394.   *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj)) =
  395.     SCM_obj_to_vect(sstate->globals[SYMBOL_TABLE].value)[h];
  396.   SCM_obj_to_vect(sstate->globals[SYMBOL_TABLE].value)[h] = probe;
  397.  
  398.   *obj = sym;
  399.   return 0;
  400. }
  401.  
  402.  
  403. long alloc_global( name, index )
  404. char *name;
  405. long *index;
  406. { SCM_obj sym;
  407.   if (alloc_symbol( name, &sym )) return 1;
  408.   return alloc_global_from_symbol( sym, index );
  409. }
  410.  
  411.  
  412. long alloc_global_from_symbol( sym, index )
  413. SCM_obj sym;
  414. long *index;
  415. { if (SCM_obj_to_vect(sym)[SYMBOL_GLOBAL] == SCM_false) /* var allocated? */
  416.   { long i = SCM_obj_to_int( sstate->globals[GLOBAL_VAR_COUNT].value );
  417.     if (i >= MAX_NB_GLOBALS)
  418.     { os_err = "Global variable table overflow"; return 1; }
  419.     SCM_obj_to_vect(sym)[SYMBOL_GLOBAL] = SCM_int_to_obj(i);
  420.     sstate->globals[GLOBAL_VAR_COUNT].value = SCM_int_to_obj(i+1);
  421.     *index = i;
  422.   }
  423.   else
  424.     *index = SCM_obj_to_int(SCM_obj_to_vect(sym)[SYMBOL_GLOBAL]);
  425.   return 0;
  426. }
  427.  
  428.  
  429. long set_global( name, value )
  430. char *name;
  431. SCM_obj value;
  432. { long index;
  433.   if (alloc_global( name, &index )) return 1;
  434.   sstate->globals[index].value = value;
  435.   return 0;
  436. }
  437.  
  438.  
  439. char *local_malloc8( len )
  440. long len;
  441. { char *temp1 = pstate->local_heap_ptr;
  442.   char *temp2 = temp1 + ceiling8( len );
  443.   if (temp2 > pstate->local_heap_top) return NULL;
  444.   pstate->local_heap_ptr = temp2;
  445.   return temp1;
  446. }
  447.  
  448.  
  449. char *local_mark()
  450. { return pstate->local_heap_ptr;
  451. }
  452.  
  453.  
  454. void local_release( mark )
  455. char *mark;
  456. { pstate->local_heap_ptr = mark;
  457. }
  458.  
  459.  
  460. /*---------------------------------------------------------------------------*/
  461.